home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Misc.sea / Misc / rcs.lisp < prev    next >
Encoding:
Text File  |  1993-02-26  |  29.8 KB  |  606 lines  |  [TEXT/CCL2]
  1. ;;; RCS.LISP (Simple Revision Control System)
  2. ;;; Version 1.5, Jan. '93 
  3. ;;; Functions for managing the editing of project code by multiple people.
  4. ;;; Hacked by David Neves - neves@ils.nwu.edu
  5. ;;;
  6. ;;; Changes:
  7. ;;; jona   (2/2/93)   Wrap menu call to copy-directory in a eval-enqueue.
  8. ;;; neves  (1/15/93)  As per Kemi's suggestion, have init-rcs put a call to itself in
  9. ;;;                   *lisp-startup-functions*.
  10. ;;; neves  (1/14/93)  use *home-directory-o* to store logical pathname of home directory.
  11. ;;; jona   (1/6/93)   balloon help and code to better display log file.
  12. ;;; neves  (12/10/92) copy-directory now prints out name of file copied. Don't ask if non-text
  13. ;;;                   files should be edited when locking them.
  14. ;;; neves  (11/12/92) Have button to Forget files be labeled as Forget rather than Unlock.
  15. ;;; neves  (10/29/92) Check to see if *server-volume* is mounted.  When locking, don't copy
  16. ;;;                   the file over if you already have the most recent version.
  17. ;;;                   Other misc changes.
  18. ;;; neves  (10/16/92) Add *files-not-to-copy* to prevent RCS bookkeeping files from being
  19. ;;;                   copied to a users local disk.  Other misc changes.
  20. ;;; neves  (10/15/92) Add help and viewing of log file
  21. ;;; neves  (10/15/92) Lock file before copying to the local disk.
  22. ;;; neves  (10/14/92) Fix pathname bugs for released MCL 2.0, add copy-directory function
  23. ;;; neves  (1/21)     Make a variable to hold folder of server volume on server machine
  24. ;;; neves  (1/7/92)   Server now has a separate working directory.
  25. ;;; neves  (12/23/91) Updated to MACL 2.0 Beta
  26. ;;;
  27. ;;; =========================================================================================
  28. ;;; Documentation:
  29. ;;;   On any large project there is a danger of 2 people editing the same file at the same time.
  30. ;;; Most likely one person's changes will be lost.  This software allows someone to "lock" a
  31. ;;; file so that no one else can edit it.  When the user is finished editing the file they
  32. ;;; can "unlock" the file so that others can edit it.
  33. ;;;   Project software is kept on a central server.  Locking a file copies that file to the user's
  34. ;;; local hard disk and stores the file name in a list of locked files on the central server. 
  35. ;;; When the user unlocks the file, the file is copied back to the server and the file name
  36. ;;; is removed from the list of locked files.
  37. ;;;   The project directory on the server may be hierarchical. Files copied from it 
  38. ;;; will be put in the same relative position on the user hard disk.  
  39. ;;; For example, the file server:foo:bar might be copied to
  40. ;;; user:foo:bar.  "foo" is a subfolder where bar is located.
  41. ;;; =========================================================================================
  42. ;;;
  43. ;;; User choices from the "lockfile" menu:
  44. ;;;   - Lock a file.  This brings up a dialog so that the user can choose a file to lock.  If
  45. ;;;     the file is already locked then the user gets an error message.  Locking a file
  46. ;;;     copies the file from the server to the local hard disk.  Then the name of the locked
  47. ;;;     file is stored in a special file ("locked-file-list") on the server.
  48. ;;;   - Unlock a file and copy to server.  This brings up a dialog with all your locked files.  
  49. ;;;     Select 1 or more files (with shift-click) to unlock.  The files are copied back to the 
  50. ;;;     server and their names are deleted from "locked-file-list".
  51. ;;;   - Unlock a file, but don't copy to server.  This is like the choice above but the files
  52. ;;;     are not copied to the server.  Useful when the user changes his/her mind about making
  53. ;;;     the changes permanent.
  54. ;;;   - Copy a newly created file to the server.  The user has just created a file on his/her
  55. ;;;     hard disk.  To move it to the server choose this.
  56. ;;;   - Update - copy server directory to local disk.  Updates all files.
  57. ;;;   - Show all locked files.  Show a list of all the locked files, along with who locked them.
  58. ;;;
  59. ;;; Hardware needed:
  60. ;;;   Each user needs a Macintosh with access to an Appleshare network.
  61. ;;;   You need a server machine that can be mounted from other Macs.
  62. ;;;
  63. ;;; Software needed:
  64. ;;;   System 7.0 (or greater) & MACL 2.0 (or greater)
  65. ;;;
  66. ;;; To install:
  67. ;;;    Simply load this file.  The LockFile menu choice will install itself.
  68.  
  69. ;;;;;;
  70. ;;; To do:
  71. ;;;    from Chung: handle multiple projects
  72. ;;;    from Kemi : use apple events to be able to edit other than text files
  73. ;;;    It would be nice if this software mounted the server volume.  I don't know how to do this.
  74. ;;;
  75. ;;; Known misfeatures:
  76. ;;; The server volume name (*outsider-server-volume*) cannot contain a subfolder.  e.g. 
  77. ;;;     "myvol:foo:" is illegal.  Just use "myvol:".
  78. ;;;
  79. ;;; Known bugs:
  80. ;;;   I suppose it is possible for 2 people to (almost) simultaneously lock the same file.  We
  81. ;;;  have never had it happen to us.
  82. ;;;
  83. ;;; Changes you have to make:
  84. ;;;   The only changes you should need to make for your project are to the defparameters below.
  85. ;;; Because a person on a server machine cannot mount their own machine
  86. ;;; I have a bunch of special case code that allows one to use this software
  87. ;;; on a server machine.
  88.  
  89. (in-package :ccl)
  90.  
  91. ;;; ------------------------------------------------------------------------------------------------
  92. ;;; change the following strings for your project.  Only the 1st 3 are required to be changed.
  93. ;(defparameter *server-name* "Chung's Macintosh")
  94. (defparameter *server-name* "Data Storage - AK Lab")  ;<used only if someone is using the server machine>
  95.                                       ;put fileserver name here.  This is the chooser name.
  96. (defparameter *home-directory-o* "ccl:MOPED;")       ;Local home directory where the project files are kept.
  97.                                                      ;This is where a file ends up when locked and copied.
  98.                 ;Note use of CL style logical pathname (page 628 of Steele)
  99.                 ;with semicolin separating directories.
  100.  
  101. (defparameter *outsider-server-volume* "Data Storage - AK Lab:MJC backup:MOPED Server:")
  102.                                                ;Server volume where the project files are kept
  103.                                                ;If someone is running on the server machine we
  104.                                                ;assume this is in ccl; (see below)
  105. (defparameter *folder-of-outsider-server-volume-on-server* "MJC backup:")
  106.                                                ;<used only if someone is using the server machine>      
  107.                                                ;location of *outsider-server-volume on server machine
  108.                                                ;e.g. on server machine -- ccl:myvol;
  109. (defparameter *filename-locked-file-list-file* "locked-file-list") 
  110.                     ;File for list of locked files
  111. (defparameter *filename-log-file* "logfile")    
  112.                     ;File for documentation on changes made to files
  113. ;;; -----------------------------------------------------------------------------------------
  114. (defvar *locked-file-list-file*) ; full pathname of locked-file-list-file
  115. (defvar *log-file*)              ; full pathname of log file
  116. (defvar *server-volume*)         ; The server machine relative to the user.
  117. (defvar *home-directory*)        ; set from home-directory-o above
  118. (defvar *files-not-to-copy*)     ; list of files not to update to local disk from server
  119. (defvar *locked-file-list*)      ; temporary list holding the contents of locked-file-list-file
  120. (defvar *rcs-menu*)              ; lock file menu
  121.  
  122. (defun on-server-p nil (equal (machine-instance) *server-name*))
  123.  
  124. (defmacro concat (&rest strings)
  125.   `(concatenate 'string ,@strings))
  126.  
  127. (defun check-server-p nil
  128.    (if (null (probe-file *server-volume*))
  129.      (progn
  130.        (message-dialog (concat "Could not find server " *server-volume* ". -- Aborting."))
  131.        nil)
  132.      t))
  133.                     
  134.  
  135. ;;; YUK!!!
  136. ;;; translate-logical-pathname works on a filename, not directory name, so make a temporary
  137. ;;; filename for it and then undo it with mac-directory.namestring.
  138. (defun rcs-mac-namestring (folder)
  139.   (mac-directory-namestring (translate-logical-pathname (concat folder "foo"))))
  140.  
  141. ;;; init-rcs is called automatically at the end of this file
  142. (defun init-rcs nil
  143.   (let ((outsider-server-volume (concat (subseq *outsider-server-volume* 0 
  144.                                                 (1- (length *outsider-server-volume*)))
  145.                                         ";"))
  146.         server-servers-volume)
  147.     (setq *home-directory* (rcs-mac-namestring *home-directory-o*))
  148.     (when (on-server-p)
  149.       (setq server-servers-volume (rcs-mac-namestring 
  150.                                    (concat *folder-of-outsider-server-volume-on-server* 
  151.                                            outsider-server-volume)))
  152.  
  153.       (setf (logical-pathname-translations 
  154.              ;; take out the colon at the end of *outsider-server-volume*
  155.              (subseq *outsider-server-volume* 0 (1- (length *outsider-server-volume*))))
  156.             ;; copied right out of steele without understanding it...
  157.             `(("**;*.*.*" ,(concat server-servers-volume "**")))))
  158.     (setq *server-volume* *outsider-server-volume*)
  159.     (when (null (check-server-p)) (return-from init-rcs))
  160.     (setq *locked-file-list-file* (concatenate 'string *server-volume* *filename-locked-file-list-file*))
  161.     (setq *log-file* (concatenate 'string *server-volume* *filename-log-file*))
  162.     (setq *files-not-to-copy* (list *locked-file-list-file* *log-file*))
  163.     (if (find-menu "LockFile") (menu-deinstall *rcs-menu*))
  164.     (setq *rcs-menu* (make-instance 'menu :menu-title "LockFile"))
  165.     (add-menu-items *rcs-menu*
  166.                    (make-instance 'menu-item
  167.                           :menu-item-title "Lock    - (a project file and copy to local disk)"
  168.                           :menu-item-action 'lock-project-file
  169.                           :help-spec 
  170.                           (format nil "Lock a file.  This brings up a dialog so that the ~
  171.                                        user can choose a file to lock. If the file is ~
  172.                                        already locked then the user gets an error message.  ~
  173.                                        Locking a file copies the file from the server to ~
  174.                                        the local hard disk."))
  175.                    (make-instance 'menu-item
  176.                           :menu-item-title "Unlock - (a project file and copy back to server)"
  177.                           :menu-item-action 'unlock-project-file
  178.                           :help-spec
  179.                           (format nil "Unlock a file and copy to server.  This brings up ~
  180.                                        a dialog with all your locked files. Select 1 or ~
  181.                                        more files (with shift-click) to unlock.  The ~
  182.                                        files are copied back to the  server."))
  183.                    (make-instance 'menu-item
  184.                           :menu-item-title "Forget - (Unlock project file but don't copy new version to server)"
  185.                           :menu-item-action 'unlock-file-dont-copy
  186.                           :help-spec 
  187.                           (format nil "Unlock a file, but don't copy to server.  This is ~
  188.                                        like 'Unlock' but the files are not copied to ~
  189.                                        the server. Useful when the user changes his/her ~
  190.                                        mind about making the changes permanent."))
  191.                    (make-instance 'menu-item
  192.                           :menu-item-title "Copy    - (newly created file to server.)"
  193.                           :menu-item-action 'copy-new-file-to-server
  194.                           :help-spec
  195.                           (format nil "Copy a newly created file to the server. The user ~
  196.                                        has just created a file on his/her hard disk.  ~
  197.                                        To move it to the server choose this."))
  198. ;                   (make-instance 'menu-item
  199. ;                          :menu-item-title "Copy logged files to local disk."
  200. ;                          :menu-item-action 'copy-logfiles-to-local-disk)
  201.                    (make-instance 'menu-item
  202.                           :menu-item-title "Update - (files on local disk)"
  203.                           :menu-item-action #'(lambda nil (eval-enqueue
  204.                                                            '(copy-directory-1 *server-volume* *home-directory*)))
  205.                           :help-spec
  206.                           (format nil "Copy server directory to local disk.  ~
  207.                                        Updates all files on local disk."))
  208.                    (make-instance 'menu-item
  209.                           :menu-item-title "Show   - (all locked files)"
  210.                           :menu-item-action 'find-all-locked-files
  211.                           :help-spec 
  212.                           (format nil "Show a list of all the locked files, ~
  213.                                        along with who locked them."))
  214.                    (make-instance 'menu-item
  215.                           :menu-item-title "Show changes   - (made to project files)"
  216.                           :menu-item-action 'show-log-file
  217.                           :help-spec 
  218.                           (format nil "Show a list of past changes to all files."))
  219.                    ;(make-instance 'menu-item
  220.                    ;       :menu-item-title "Help"
  221.                    ;       :menu-item-action 'show-help)
  222.                    )
  223.   (menu-install *rcs-menu*)
  224.   
  225.   (load-locked-file-list)
  226.  
  227.   (unless (member 'init-rcs *lisp-startup-functions*)
  228.     (setf *lisp-startup-functions*
  229.           (nconc *lisp-startup-functions* (list 'init-rcs))))
  230.   
  231.   
  232.   ))
  233.  
  234. (defun server-to-logical-server-name (file)
  235.   (concat *server-volume*
  236.           (strip-left (namestring (translate-logical-pathname *server-volume*))
  237.                       file)))
  238.  
  239. ;;; lock a file
  240. (defun lock-project-file nil
  241.   (let (longfilename
  242.         tofile
  243.         tofileyounger
  244.         within
  245.         (server-volume (namestring (translate-logical-pathname *server-volume*)))
  246.         (default-choose-directory (choose-file-default-directory))
  247.         )
  248.     (when (string-equal (machine-instance) "")
  249.       (message-dialog "Aborted because you have not named your Mac.  Please name your computer in Sharing Setup in Control Panels.")
  250.       (return-from lock-project-file))
  251.     (when (null (check-server-p)) (return-from lock-project-file))
  252.     (setq longfilename 
  253.           (catch-cancel 
  254.             (choose-file-dialog :directory *server-volume*
  255.                                 :button-string "Lock file"
  256.                                 )))
  257.     (set-choose-file-default-directory default-choose-directory)
  258.     (when (neq longfilename :cancel)
  259.       (setq longfilename (namestring longfilename))
  260.       (setq within (search server-volume longfilename))
  261.       (when (or (null within) (not (zerop within)))
  262.         (message-dialog 
  263.          (concat "Locked file was not contained within " server-volume " -- Aborting command."))
  264.         (return-from lock-project-file))
  265.       (setq longfilename (server-to-logical-server-name longfilename))
  266.       (when (is-locked-filep longfilename)
  267.         (message-dialog (concat longfilename " is already locked.  Aborting command."))
  268.         (return-from lock-project-file))
  269.       (setq tofile (server-to-home-name longfilename))
  270.       (setq tofileyounger (is-youngerp tofile longfilename))
  271.       (when (or (not tofileyounger)
  272.                 (and tofileyounger
  273.                      (eq t (catch-cancel (y-or-n-dialog
  274.                                           "The file on the local disk is younger than the one on the server.  Should I still copy it?")))))
  275.         (if (probe-file tofile) (unlock-file tofile))
  276.         (update-locked-file-list longfilename :add)
  277.         (when (null (is-same-age longfilename tofile))
  278.           (copy-file longfilename tofile
  279.                      :if-exists :overwrite))
  280.         (when
  281.           (and (eq (mac-file-type tofile) :TEXT)
  282.                (y-or-n-dialog  
  283.                 (concat longfilename " has been copied to your disk and is locked.  To edit the file click on EDIT, otherwise click on OK.")
  284.                 :yes-text "EDIT" :no-text "OK" :cancel-text nil))
  285.           (ed tofile))
  286.        ))))
  287.  
  288. (defun is-youngerp (file1 file2)
  289.   (and (probe-file file1) (probe-file file2) (> (file-write-date file1) (file-write-date file2))))
  290.  
  291. (defun is-same-age (file1 file2)
  292.   (and (probe-file file1) (probe-file file2) (eql (file-write-date file1) (file-write-date file2))))
  293.  
  294. ;;; format of locked-file-list is ((filename . person) (filename . person) ...)
  295.  
  296. (defun is-locked-filep (filename)
  297.   (load-locked-file-list)
  298.   (assoc filename *locked-file-list* 
  299.          :test #'string-equal))
  300.  
  301. (defun load-locked-file-list nil
  302.   (if (null (probe-file *locked-file-list-file*))
  303.     (with-open-file (stream *locked-file-list-file* :direction :output)
  304.       (print nil stream)))
  305.   (setq *locked-file-list*
  306.           (with-open-file  (stream *locked-file-list-file* :direction :input)
  307.             (read stream))))
  308.  
  309. (defun save-locked-file-list nil
  310.   (let ((tempfilename (concat *locked-file-list-file* "temp")))
  311.     (with-open-file (stream tempfilename :direction :output :if-exists :supersede)
  312.       (print *locked-file-list* stream))
  313.     (rename-file tempfilename *locked-file-list-file* :if-exists :overwrite)))
  314.  
  315. (defun username nil (machine-instance))
  316.  
  317. (defun make-pair (&key filename person)
  318.   (cons filename person))
  319. (defun get-person (pair)
  320.   (rest pair))
  321. (defun get-filename (pair)
  322.   (first pair))
  323.  
  324. ;;; ------------------------------------------------------------------------------------
  325. ;;; unlock a file
  326. (defun unlock-project-file (&optional (dontcopyflag nil))
  327.    (let ((username (machine-instance))
  328.          (homefilename)
  329.          (serverfilenames))
  330.     (when (eql username "")
  331.       (message-dialog "Aborted because you have not named your Mac.  Please name your computer in Sharing Setup in Control Panels.")
  332.       (return-from unlock-project-file))
  333.     (when (null (check-server-p)) (return-from unlock-project-file))
  334.      (setq serverfilenames 
  335.            (catch-cancel 
  336.             (select-item-from-list (find-my-locked-files) :selection-type :disjoint
  337.                                    :default-button-text 
  338.                                    (if dontcopyflag "Forget" "Unlock"))))
  339.      (when (neq serverfilenames :cancel)
  340.       (dolist (serverfilename serverfilenames)
  341.         ;; doncopyflag means unlock the file but don't copy your version to the project directory
  342.         (setq homefilename (server-to-home-name serverfilename))  ;;JL--removed from the WHEN below     
  343.         (when (null dontcopyflag)
  344.           (if (probe-file homefilename)  
  345.             (copy-to-server-and-update-logfile homefilename serverfilename)
  346.             (format t "You do not have ~a to copy to the project directory~%" homefilename))
  347.         )
  348.      ;;   (let ((window (find-window (pathname-name homefilename))))
  349.      ;;     (when window (window-close window)))         JL--closing the homefile window, if its here
  350.      ;;   (lock-file homefilename)   JL--locking the homefile
  351.         (update-locked-file-list serverfilename :delete)
  352.         ))))
  353.  
  354. ;;; Given a name on the server, construct the corresponding name on the home directory.
  355. (defun server-to-home-name (filename)
  356.   (concat *home-directory* 
  357.           (strip-left *server-volume* (namestring filename))))
  358.  
  359. ;;; Given a name on the home directory, construct a name for the server
  360. (defun home-to-server-name (filename) 
  361.   (concat *server-volume*
  362.           (strip-left *home-directory*  (namestring filename))))
  363.  
  364. (defun copy-to-server-and-update-logfile (homefilename serverfilename)
  365.   (when (or (null (probe-file serverfilename))
  366.           (>= (file-write-date homefilename) (file-write-date serverfilename))
  367.           (eq t (catch-cancel (y-or-n-dialog
  368.                                "The file on the local disk is older than the one on the server.  Should I still copy it?"))))
  369.    ;;   (when (probe-file serverfilename)
  370.    ;;    (unlock-file serverfilename))     ;;JL--unlock the serverfile if it's there
  371.     (copy-file homefilename serverfilename :if-exists :overwrite)
  372.    ;;  (lock-file serverfilename)     JL--lock the serverfile
  373.    ;; (let ((window (find-window (pathname-name homefilename))))
  374.    ;;   (when window (window-close window)))   JL--close the homefile window if its there
  375.    ;; (lock-file homefilename)      JL--lock the homefile (now that window is closed
  376.       ;; make sure the dates on both files are the same in case clocks are off on
  377.       ;; both machines. 
  378.     (set-file-write-date homefilename (file-write-date serverfilename))
  379.     (update-log-file serverfilename)
  380.       ))
  381.  
  382. (defun copy-new-file-to-server nil
  383.   (let (homefilename serverfilename within)
  384.     (message-dialog "Please select a newly created file to copy to the server.")
  385.     (setq homefilename 
  386.           (catch-cancel (choose-file-dialog :directory *home-directory*
  387.                                 )))
  388.     (when (neq homefilename :cancel)
  389.       (setq homefilename (namestring homefilename))
  390.       (setq within (search *home-directory* homefilename))
  391.       (when (or (null within) (not (zerop within)))
  392.         (message-dialog 
  393.          (concat "New file was not contained within " *home-directory* " -- Aborting command."))
  394.         (return-from copy-new-file-to-server))
  395.       (setq serverfilename (home-to-server-name homefilename))
  396.       (when (probe-file serverfilename)
  397.         (message-dialog (concat serverfilename " already exists.  Aborting command."))
  398.         (return-from copy-new-file-to-server))
  399.       (copy-to-server-and-update-logfile homefilename serverfilename)
  400.       )))
  401.     
  402. (defun update-locked-file-list (file operation)
  403.   (load-locked-file-list)
  404.   (let ((newpair (make-pair :filename file :person (username))))
  405.     (cond
  406.      ((eq operation :add) 
  407.       (pushnew newpair *locked-file-list*))
  408.    ((eq operation :delete) 
  409.     (setq *locked-file-list* 
  410.           (delete newpair *locked-file-list* :test #'equal)))
  411.    (t (error "illegal operation in update-locked-file-list")))
  412.   (save-locked-file-list)))
  413.  
  414. (defun update-log-file (filename)
  415.   (setq filename (namestring filename))
  416.   (let ((changes))
  417.     (with-open-file (stream *log-file* :direction :output :if-exists :append :if-does-not-exist :create)
  418.       (setq changes (catch-cancel 
  419.                      (get-string-from-user (concat "File " filename " has been copied to the server.  Describe your changes to the file here."))))
  420.       (format stream "~a \"~a\" ~a -- ~a~%" (machine-instance) filename (return-the-date) changes)
  421.       )))
  422.  
  423. (defun return-the-date nil
  424.   (multiple-value-bind  (second minute hour date month year 
  425.                                 day-of-week daylight-saving-timep time-zone)                        
  426.                         (get-decoded-time)
  427.     (declare (ignore second year day-of-week daylight-saving-timep time-zone))
  428.     (format nil "(~a:~2,'0d ~a/~2,'0d)" hour minute month date)))
  429.   
  430. (defun find-my-locked-files nil
  431.   (find-user-locked-files (username)))
  432.  
  433. (defun find-user-locked-files (user)
  434.   (mapcar 'get-filename
  435.           (remove user *locked-file-list* 
  436.                   :test #'(lambda (user y) (not (equal user (get-person y)))))))
  437.       
  438. (defun find-people-with-locked-files nil
  439.   (let (people)
  440.     (dolist (pair *locked-file-list*)
  441.       (pushnew (get-person pair) people :test #'equal))
  442.     people))
  443.  
  444. (defun find-all-locked-files nil
  445.   (load-locked-file-list)
  446.   (show-listener)
  447.   (format t "~%--Locked file list--~%")
  448.   (if (null *locked-file-list*) (format t "There are no locked files.")
  449.       (dolist (person (find-people-with-locked-files))
  450.         (format t "Locked files for ~a:~%" person)
  451.         (dolist (file (find-user-locked-files person))
  452.           (format t "   ~a~%" file)))))
  453.  
  454. (defun show-listener nil
  455.   (window-select (find-window "Listener")))
  456.  
  457. (defun unlock-file-dont-copy nil
  458.   (unlock-project-file t))
  459.  
  460. ;;; copy a file and make sure the write dates are the same on both files
  461. (defun copy-file-and-set-write-date (fromfile tofile)
  462.   (copy-file fromfile tofile :if-exists :overwrite)
  463.   (set-file-write-date tofile (file-write-date fromfile)))
  464.  
  465. ;;;-----
  466. ;;; Copy files from logfile to local disk.  Remove duplicate names in logfile list of files.
  467. ;;; BUGS: doesn't check to see if local files are more recent than server files.
  468. ;;; This function is currently not being used.
  469. (defun copy-logfiles-to-local-disk nil
  470.     (let (linelist selectlist tofile fromfilelist)
  471.       (with-open-file  (finput *log-file* :direction :input)
  472.         (setq linelist
  473.               (do* ((line (read-line finput nil :eof)(read-line finput nil :eof))
  474.                     (linelist)
  475.                     (pos))
  476.                    ((eq line :eof) linelist)
  477.                 (setq pos (position #\" line)) ;kludge for testing for a filename in line
  478.                 (if pos
  479.                   (push line linelist)))))
  480.       (setq selectlist
  481.             (catch-cancel 
  482.               (select-item-from-list linelist :selection-type :disjoint)))
  483.       (when (and selectlist (not (eq selectlist :cancel)))
  484.         (show-listener)
  485.         (setq fromfilelist
  486.               (mapcar #'(lambda (line) (read-from-string line nil nil :start (position #\" line)))
  487.                       selectlist))
  488.         (setq fromfilelist (remove-duplicates fromfilelist :test #'string-equal))
  489.         (dolist (fromfile fromfilelist)
  490.           (if (probe-file fromfile)
  491.             (progn
  492.               (setq tofile (server-to-home-name fromfile))
  493.               (format t "~%About to copy file ~a to ~a -- " fromfile tofile)
  494.               (copy-file-and-set-write-date fromfile tofile)
  495.               (format t "DONE"))
  496.             (format t "~%Did not copy file ~a because I could not find it." fromfile))))))
  497.     
  498.  
  499. (defun rcs-directoryp (string)
  500.   (eql #\: (char string (1- (length string)))))
  501.  
  502. (defun copy-directory-1 (from to)
  503.   (show-listener)
  504.   (format t "~%About to copy ~s to ~s ~%" from to)
  505.   (copy-directory from to t nil)
  506.   (format t "~%DONE!~%")
  507.   )
  508.  
  509. ;;; copy one directory to another directory
  510.  
  511. ;;; verboseflag,if true, prints out a DOT when a file is read in
  512. ;;; purge, if true, deletes the destination directory
  513.  
  514. (defun copy-directory (from to &optional (verboseflag t) (purge nil))
  515.   (setq from (namestring from)
  516.         to   (namestring to))
  517.   (when verboseflag (show-listener))
  518.   (unless (and (rcs-directoryp from) (probe-file from) (rcs-directoryp to) (not (equal from to)))
  519.     (cond
  520.      ((null (rcs-directoryp from)) (format t "~s is not a directory name, aborted" from))
  521.      ((null (probe-file from)) (format t "Could not find directory ~s, aborted" from))
  522.      ((null (rcs-directoryp to)) (format t "~s is not a directory name, aborted" to))
  523.      ((equal from to) (format t "~s, source and destination directories are the same, aborted")))
  524.     (return-from copy-directory))
  525.   (if (or purge (null (probe-file to))) (create-file to :if-exists nil))
  526.   (dolist (fromfile (list-of-files from))
  527.     (let* ((filename (file-namestring fromfile))
  528.            (tofile (merge-pathnames to filename))
  529.            (tofilepresent (probe-file tofile))
  530.            (fromfilewritedate (file-write-date fromfile))
  531.            (tofilewritedate (and tofilepresent (file-write-date tofile))))
  532.       ;;copy only if no file or new version of file
  533. ;      (when verboseflag 
  534. ;        (princ ".")
  535. ;        (fred-update *TOP-LISTENER*))
  536.       (cond ((member (server-to-logical-server-name (namestring fromfile)) *files-not-to-copy* :test #'string-equal))
  537.             ((or (null tofilepresent) 
  538.                  (< tofilewritedate fromfilewritedate))
  539.              (if tofilepresent (unlock-file tofile))
  540.              (copy-file fromfile tofile :if-exists :overwrite)
  541.              (lock-file tofile)
  542.              (when verboseflag (format t "~%~a copied." fromfile))
  543.              (set-file-write-date tofile fromfilewritedate))
  544.             ((and tofilewritedate (> tofilewritedate fromfilewritedate))
  545.              (format t "~%Your version of ~a is newer than the server's version so it was left untouched."
  546.                      tofile)))))
  547.   (dolist (dir (directory (concat from "*.*") :directories t :files nil)) ;mac specific
  548.     (let* ((newfromdir (directory-namestring dir))
  549.            (newpartdir (strip-left from newfromdir))
  550.            (newtodir (concat to newpartdir)))
  551.       (copy-directory newfromdir newtodir verboseflag purge))))
  552.  
  553.       
  554. ;;; strip (length sub) characters from the left part of seq
  555. ;;; Used to strip off part of a directory from seq
  556. ;;; e.g. (strip-left "hd:" "hd:foo:") --> "foo:"
  557. (defun strip-left (sub seq)
  558.   (subseq seq (length sub)))
  559.  
  560. ;;; Return a list of files in directory "dir"
  561. ;;; function is probably WRONG
  562. (defun list-of-files (dir)
  563.   (directory (concat dir "*.*")))
  564.  
  565. (defun show-help ()
  566.  (message-dialog 
  567. "                    User choices from the lockfile menu:
  568.    - Lock a file.  This brings up a dialog so that the user can choose a 
  569.      file to lock.
  570.      If the file is already locked then the user gets an error message.  
  571.      Locking a file copies the file from the server to the local hard disk.
  572.  
  573.    - Unlock a file and copy to server.  This brings up a dialog with all 
  574.      your locked files.  
  575.      Select 1 or more files (with shift-click) to unlock.  
  576.      The files are copied back to the  server.
  577.  
  578.    - Forget. Unlock a file, but don't copy to server.  
  579.      This is like the choice above but the files are not copied to the server.  
  580.      Useful when the user changes his/her mind about making the 
  581.      changes permanent.
  582.  
  583.    - Copy a newly created file to the server.  
  584.      The user has just created a file on his/her hard disk.  
  585.      To move it to the server choose this.
  586.  
  587.    - Update - copy server directory to local disk.  
  588.      Updates all files on local disk.
  589.  
  590.    - Show all locked files.  
  591.      Show a list of all the locked files, along with who locked them.
  592.  
  593.    - Show a list of past changes to files.
  594. "
  595. :size (make-point *screen-width* (- *screen-height* 40))))
  596.  
  597. (defun show-log-file nil
  598.   (let ((win (make-instance 'fred-window
  599.                :window-title "RCS Change Log"
  600.                :scratch-p t)))
  601.     (buffer-insert-file (fred-display-start-mark win) 
  602.                         *log-file*)
  603.     (fred-update win)))
  604.  
  605. ;;; ------------------------------------------------------------------------------
  606. (init-rcs)